"
SUnit tests for classes
"
Class {
	#name : 'ClassTest',
	#superclass : 'ClassTestCase',
	#instVars : [
		'className',
		'testEnvironment'
	],
	#category : 'Kernel-Extended-Tests-Classes',
	#package : 'Kernel-Extended-Tests',
	#tag : 'Classes'
}

{ #category : 'coverage' }
ClassTest >> classToBeTested [

	^ Class
]

{ #category : 'setup' }
ClassTest >> deleteClass [

	testEnvironment at: className ifPresent: [ :class | class removeFromSystemUnlogged ]
]

{ #category : 'setup' }
ClassTest >> packageNameForTest [
	"Answer the category where to classify temporarily created classes"

	^'Dummy-Tests-Class'
]

{ #category : 'referencing methods' }
ClassTest >> referencingMethod1 [

	^ ExampleForTest1
]

{ #category : 'referencing methods' }
ClassTest >> referencingMethod2 [

	^ {ExampleForTest12. ExampleForTest1}
]

{ #category : 'referencing methods' }
ClassTest >> referencingMethod3 [
	"no reference"

	^ self
]

{ #category : 'running' }
ClassTest >> setUp [
	super setUp.
	className := #TUTU.
	testEnvironment:= Smalltalk globals.
	self deleteClass.

	self class classInstaller make: [ :aBuilder |
		aBuilder
			name: className;
			package: self packageNameForTest]
]

{ #category : 'running' }
ClassTest >> tearDown [

	self deleteClass.

	self packageOrganizer removePackage: self packageNameForTest.

	super tearDown
]

{ #category : 'tests' }
ClassTest >> testAddClassSlot [
	| tutu slot1 slot2 |
	tutu := testEnvironment at: #TUTU.
	slot1 := #X => InstanceVariableSlot.
	slot2 := #Y => InstanceVariableSlot.
	tutu addClassSlot: slot1.
	self assert: tutu class instVarNames equals: #(#X).
	tutu addClassSlot: slot2.
	self assert: tutu class instVarNames equals: #(#X #Y)
]

{ #category : 'tests' }
ClassTest >> testAddInstVarName [

	| tutu |
	tutu := testEnvironment at: #TUTU.
	tutu addInstVarNamed: 'x'.
	self assert: tutu instVarNames equals: #('x').
	tutu addInstVarNamed: 'y'.
	self assert: tutu instVarNames equals: #('x' 'y')
]

{ #category : 'tests' }
ClassTest >> testAddSlot [

	| tutu |
	tutu := testEnvironment at: #TUTU.
	tutu addSlot: #x => InstanceVariableSlot.
	self assert: tutu instVarNames equals: #('x').
	self assert: tutu name equals: #TUTU.
	tutu addSlot: #y => InstanceVariableSlot.
	self assert: tutu instVarNames equals: #('x' 'y').
	self assert: (tutu slotNamed: #x) definingClass identicalTo: tutu.
	self assert: (tutu slotNamed: #y) definingClass identicalTo: tutu.
]

{ #category : 'tests' }
ClassTest >> testAddSlotAnonymous [

	| tutu |
	tutu := Object newAnonymousSubclass.
	self assert: tutu getName isNil.
	tutu := tutu addSlot: #x => InstanceVariableSlot.
	self assert: tutu instVarNames equals: #('x').
	self assert: tutu getName isNil.
	tutu := tutu addSlot: #y => InstanceVariableSlot.
	self assert: tutu getName isNil.
	self assert: tutu instVarNames equals: #('x' 'y').
	self assert: (tutu slotNamed: #x) definingClass identicalTo: tutu.
	self assert: (tutu slotNamed: #y) definingClass identicalTo: tutu.
]

{ #category : 'tests - access' }
ClassTest >> testAllSharedPools [

	self assertEmpty: PoolDefiner allSharedPools.

	self assert: RootClassPoolUser allSharedPools first equals: PoolDefiner.
	self assert: RootClassPoolUser allSharedPools size equals: 1.

	"a metaclass does not have shared pools since only classes have shared pools"
	self assertEmpty: RootClassPoolUser class allSharedPools.

	self assert: ClassMultiplePoolUser allSharedPools size equals: 2.
	
	"allSharedPools lists inherited pools"
	self assert: SubclassPoolUser allSharedPools size equals: 1.
]

{ #category : 'tests' }
ClassTest >> testChangingShapeDoesNotPutNilInMethodsLastLiteralKey [
	"Test that when the shape of a class changes, the key of the last literal of the methods is not nil"
	| tutu |
	tutu := testEnvironment at: #TUTU.
	tutu compile: 'foo'.
	self deny: (tutu >> #foo) allLiterals last key isNil.
	tutu addInstVarNamed: 'x'.
	self deny: (tutu >> #foo) allLiterals last key isNil
]

{ #category : 'test - accessing parallel hierarchy' }
ClassTest >> testClassSide [

	self assert: Point classSide equals: Point class.
	self assert: Point class classSide equals: Point class
]

{ #category : 'tests' }
ClassTest >> testClassVariableEntanglement [
	| firstClassName firstClass secondClassName secondClass thirdClassName thirdClass |
	<ignoreNotImplementedSelectors: #(myVar myVar:)>
	firstClassName := 'MyFirstClass'.

	firstClass := self class classInstaller make: [ :aBuilder |
		aBuilder
			name: firstClassName;
			sharedVariables: {#MyVar};
			package: self packageNameForTest ].

	[

		firstClass class compile: 'myVar
	^ MyVar'.
		firstClass class compile: 'myVar: anObject
	MyVar := anObject'.

		secondClassName := 'MySecondClass'.

		secondClass := self class classInstaller make: [ :aBuilder |
			aBuilder
				name: secondClassName;
				sharedVariables: {#MyVar};
				package: self packageNameForTest ].

		[

			secondClass class compile: 'myVar
	^ MyVar'.
			secondClass class compile: 'myVar: anObject
		MyVar := anObject'.

			thirdClassName := 'MyThirdClass'.
			thirdClass := secondClass duplicateClassWithNewName: thirdClassName.
			[

				self assert: firstClass myVar equals: nil.
				self assert: secondClass myVar equals: nil.
				self assert: thirdClass myVar equals: nil.

				firstClass myVar: 123.
				self assert: firstClass myVar equals: 123.
				self assert: secondClass myVar equals: nil.
				self assert: thirdClass myVar equals: nil.

				secondClass myVar: 456.
				self assert: firstClass myVar equals: 123.
				self assert: secondClass myVar equals: 456.
				self assert: thirdClass myVar equals: nil.

				thirdClass myVar: 789.
				self assert: firstClass myVar equals: 123.
				self assert: secondClass myVar equals: 456.
				self assert: thirdClass myVar equals: 789.

			 ] ensure: [ thirdClass removeFromSystemUnlogged ].
		 ] ensure: [ secondClass removeFromSystemUnlogged ].
	 ] ensure: [ firstClass removeFromSystemUnlogged ]
]

{ #category : 'tests - accessing - comments' }
ClassTest >> testComment [
	self assert: Object comment isNotNil.
	self assert: Object class comment equals: Object comment
]

{ #category : 'tests - accessing - comments' }
ClassTest >> testCommentSourcePointer [

	self
		assert: Object class commentSourcePointer
		identicalTo: Object commentSourcePointer
]

{ #category : 'tests - accessing - comments' }
ClassTest >> testCommentStamp [
	self assert: Object commentStamp equals: ''.
	self assert: Object class commentStamp equals: ''.
]

{ #category : 'tests' }
ClassTest >> testCommonSuperclassWith [
	self assert: (OrderedCollection commonSuperclassWith: Array) equals: SequenceableCollection.
	self assert: (OrderedCollection commonSuperclassWith: OrderedCollection) equals: SequenceableCollection.
	"if the reveiver is the common superclass, return it"
	self assert: (ProtoObject commonSuperclassWith: Object) equals: ProtoObject.
	"but the other way this is not true"
	self assert: (Object commonSuperclassWith: ProtoObject) equals: nil.
	"as nil is the terminator of the hierarchy, we have to support it"
	self assert: (nil commonSuperclassWith: ProtoObject) equals: nil
]

{ #category : 'tests' }
ClassTest >> testCompileAll [
	ClassTest compileAll
]

{ #category : 'tests - dependencies' }
ClassTest >> testDependencies [

	"A class depends on all classes it refers to.
	Thus, this class depends on all classes referenced by this method"
	self assert: (self class dependentClasses includes: TestCase).
	self assert: (self class dependentClasses includes: Class)
]

{ #category : 'accessing' }
ClassTest >> testEnvironment [
	^ testEnvironment
]

{ #category : 'accessing' }
ClassTest >> testEnvironment: anObject [
	testEnvironment := anObject
]

{ #category : 'tests - class variables' }
ClassTest >> testHasClassVarNamed [

	self assert: (Character hasClassVarNamed: #CharSet).
	self deny: (Character hasClassVarNamed: #NotCharSet)
]

{ #category : 'tests - accessing - comments' }
ClassTest >> testHasComments [
	self assert: Object hasComment.
	self assert: Object class hasComment
]

{ #category : 'tests - access' }
ClassTest >> testHasSharedPools [

	"a metaclass does not have shared pools since only classes have shared pools"
	self deny: RootClassPoolUser class hasSharedPools.

	self assert: RootClassPoolUser hasSharedPools.

	"has shared pools does not take into account the fact that a superclass may use some shared pools"
	self deny: SubclassPoolUser hasSharedPools
]

{ #category : 'test - accessing parallel hierarchy' }
ClassTest >> testInstanceSide [

	self assert: Point instanceSide equals: Point.
	self assert: Point class instanceSide equals: Point
]

{ #category : 'test - accessing parallel hierarchy' }
ClassTest >> testIsClassSide [

	self deny: Point isClassSide.
	self assert: Point class isClassSide
]

{ #category : 'test - accessing parallel hierarchy' }
ClassTest >> testIsInstanceSide [

	self assert: Point isInstanceSide.
	self deny: Point class isInstanceSide
]

{ #category : 'tests - navigation' }
ClassTest >> testMethodsReferencingClass [
	self assert: (ClassTest methodsReferencingClass: (Smalltalk classNamed: #ExampleForTest111)) equals: {(ClassTest >> #testOrdersACollectionOfClassesBySuperclass)}.
	self
		assert: ((ClassTest methodsReferencingClass: (Smalltalk classNamed: #ExampleForTest1)) sort: [ :a :b | a name <= b name ]) asArray
		equals: {(ClassTest >> #referencingMethod1) . (ClassTest >> #referencingMethod2) . (ClassTest >> #testOrdersACollectionOfClassesBySuperclass)}.
	self assertEmpty: (ClassTest methodsReferencingClass: (Smalltalk classNamed: #BehaviorTest))
]

{ #category : 'tests - navigation' }
ClassTest >> testMethodsReferencingClasses [

	| collectionOfMethods collectionOfMethodsShouldBe |

	collectionOfMethods := ((ClassTest methodsReferencingClasses: {Smalltalk classNamed: #ExampleForTest12. Smalltalk classNamed: #ExampleForTest1}) sort: [ :a :b | a name <= b name]) asArray.

	collectionOfMethodsShouldBe := {
		ClassTest>>#referencingMethod1.
		ClassTest>>#referencingMethod2.
		ClassTest>>#testOrdersACollectionOfClassesBySuperclass}.

	self assert: collectionOfMethods asSet equals: collectionOfMethodsShouldBe asSet
]

{ #category : 'tests - class creation' }
ClassTest >> testNewSubclass [

	| class |
	[
	class := Point newSubclass.
	self assert: class isBehavior.
	self assert: class superclass identicalTo: Point.
	self assert: (Point allSubclasses includes: class).
	self assert: class instVarNames equals: #(  ).
	self assert: class package isUndefined.
	self assert: class classVarNames equals: #(  ) ] ensure: [ class ifNotNil: [ class removeFromSystem ] ]
]

{ #category : 'tests - file in/out' }
ClassTest >> testOrdersACollectionOfClassesBySuperclass [
	| ordered |
	ordered := (Class superclassOrder:
		(OrderedCollection
				with: ExampleForTest11 class
				with: ExampleForTest111 class
				with: ExampleForTest12 class
				with: ExampleForTest1 class
				with: ExampleForTest12 class
				with: ExampleForTest112 class)).

	self assert: (ordered indexOf: ExampleForTest1 class) < (ordered indexOf: ExampleForTest11 class).
	self assert: (ordered indexOf: ExampleForTest11 class) < (ordered indexOf: ExampleForTest111 class).
	self assert: (ordered indexOf: ExampleForTest11 class) < (ordered indexOf: ExampleForTest112 class).
	self assert: (ordered indexOf: ExampleForTest1 class) < (ordered indexOf: ExampleForTest12 class)
]

{ #category : 'tests - file in/out' }
ClassTest >> testOrdersMetaClassAfterItsClassInstance [
	| ordered |
	ordered := (Class superclassOrder:
		(OrderedCollection
				with: Boolean class
				with: True
				with: Boolean
				with: True class)).

	self assert: (ordered indexOf: Boolean) < (ordered indexOf: Boolean class).
	self assert: (ordered indexOf: True) < (ordered indexOf: True class).
	self assert: (ordered indexOf: Boolean class) < (ordered indexOf: True class).
	self assert: (ordered indexOf: Boolean) < (ordered indexOf: True)
]

{ #category : 'tests - pools' }
ClassTest >> testPoolVariableAccessibleInClassUser [
	"This test shows that a Pool Variable is accessible from the class that declare the Pool usage: here the superclass"

	PoolDefiner initialize.
	RootClassPoolUser compileAll.

	self assert: RootClassPoolUser gloups equals: 42.
	self assert: RootClassPoolUser author equals: 'Ducasse'
]

{ #category : 'tests - pools' }
ClassTest >> testPoolVariableAccessibleInSubclassOfClassUser [
	"This test shows that a Pool Variable is not accessible from a subclass that declare the Pool usage: here SubFlop subclass of Flop and this is a bug. "

	PoolDefiner initialize.
	SubclassPoolUser compileAll.

	self assert: SubclassPoolUser gloups equals: 42.
	self assert: SubclassPoolUser author equals: 'Ducasse'
]

{ #category : 'tests - navigation' }
ClassTest >> testReferencedClasses [
	{(ExceptionTester -> { MyTestNotification. Warning. String. MyResumableTestError. OrderedCollection. MyTestError}).
	 (CollectionCombinator -> {Array}).
	 (ExecutionEnvironmentStub -> {OrderedCollection}).
	 (ReferencedClassesTestClass -> {Array. OrderedCollection. Object})
	}
		do: [ :assoc |
			self assert: assoc key referencedClasses notEmpty.
			self assert: (assoc key referencedClasses asSet includesAll: assoc value asSet)].

	"classes referenced from class variables should not be seen as referenced statically"
	self assert: (SmalltalkImage class>>#compilerClass ) referencedClasses isEmpty
]

{ #category : 'tests' }
ClassTest >> testRemoveClassSlot [
	| tutu slot1 slot2 |
	tutu := testEnvironment at: #TUTU.
	slot1 := #X => InstanceVariableSlot.
	slot2 := #Y => InstanceVariableSlot.
	tutu addClassSlot: slot1.
	self assert: tutu class instVarNames equals: #(#X).
	tutu addClassSlot: slot2.
	self assert: tutu class instVarNames equals: #(#X #Y).
	tutu removeClassSlot: slot2.
	self assert: tutu class instVarNames equals: #(#X).
	tutu removeClassSlot: slot1.
	self assert: tutu class instVarNames equals: #()
]

{ #category : 'tests' }
ClassTest >> testRemoveSlot [

	| slotx tutu |
	tutu := testEnvironment at: #TUTU.
	tutu addSlot: (slotx := #x => InstanceVariableSlot).
	tutu addSlot: #y => InstanceVariableSlot.
	self assert: tutu instVarNames equals: #('x' 'y').
	tutu removeSlot: slotx.
	self assert: tutu instVarNames equals: #('y').
	self assert: (tutu slotNamed: #y) definingClass identicalTo: tutu.
]

{ #category : 'tests - access' }
ClassTest >> testSharedPoolOfVarNamed [

	"a metaclass does not have shared pools since only classes have shared pools"
	self assert: (RootClassPoolUser class sharedPoolOfVarNamed: 'NonExistingSharedPoolVariableName') isNil.

	self assert: (RootClassPoolUser sharedPoolOfVarNamed: 'AnAuthor') equals: PoolDefiner.
	self assert: (RootClassPoolUser sharedPoolOfVarNamed: 'Gloups') equals: PoolDefiner.
	self assert: (SubclassPoolUser sharedPoolOfVarNamed: 'AnAuthor') equals: PoolDefiner.

	self assert: (ClassMultiplePoolUser sharedPoolOfVarNamed: 'AnAuthor') equals: PoolDefiner.
	self assert: (ClassMultiplePoolUser sharedPoolOfVarNamed: 'VariableInPoolDefiner2') equals: PoolDefiner2.
	self assert: (ClassMultiplePoolUser sharedPoolOfVarNamed: 'Gloups') equals: PoolDefiner
]

{ #category : 'tests - access' }
ClassTest >> testSharedPools [

	self assertEmpty: PoolDefiner sharedPools.

	self assert: RootClassPoolUser sharedPools first equals: PoolDefiner.
	self assert: RootClassPoolUser sharedPools size equals: 1.

	"a metaclass does not have shared pools since only classes have shared pools"
	self assertEmpty: RootClassPoolUser class sharedPools.

	self assert: ClassMultiplePoolUser sharedPools size equals: 2.
	
	"sharedPool does not list inherited pools"
	self assertEmpty: SubclassPoolUser sharedPools
]

{ #category : 'tests - class creation' }
ClassTest >> testSubclass [

	| class |
	(testEnvironment includesKey: #SubclassExample) ifTrue: [ (testEnvironment at: #SubclassExample) removeFromSystem ].

	self deny: (testEnvironment includesKey: #SubclassExample).
	[
	class := self class classInstaller make: [ :aBuilder | aBuilder name: #SubclassExample ].

	self assert: (testEnvironment includesKey: #SubclassExample).

	self assert: (testEnvironment at: #SubclassExample) identicalTo: class.
	self assert: class package isUndefined.
	self assert: class instVarNames equals: #(  ) ] ensure: [ class ifNotNil: [ class removeFromSystem ] ]
]

{ #category : 'tests - class creation' }
ClassTest >> testSubclassInstanceVariableNames [

	| class |
	(testEnvironment includesKey: #SubclassExample) ifTrue: [ (testEnvironment at: #SubclassExample) removeFromSystem ].

	self deny: (testEnvironment includesKey: #SubclassExample).

	[
	class := self class classInstaller make: [ :aBuilder |
		       aBuilder
			       name: #SubclassExample;
			       slots: #(x y) ].

	self assert: (testEnvironment includesKey: #SubclassExample).

	self assert: (testEnvironment at: #SubclassExample) identicalTo: class.
	self assert: class package isUndefined.
	self assert: class instVarNames equals: #( 'x' 'y' ) ] ensure: [ class ifNotNil: [ class removeFromSystem ] ]
]

{ #category : 'tests - file in/out' }
ClassTest >> testSuperclassOrder [
	|  ordered orderedSuperclasses shuffledSuperclasses |
	orderedSuperclasses := {ProtoObject. Object. Collection. SequenceableCollection}.

	"a shuffled collection of superclasses of OrderedCollection"
	shuffledSuperclasses := {Collection. SequenceableCollection. ProtoObject. Object}.

	ordered := Class superclassOrder: shuffledSuperclasses.

	"should not affect the order as there is no dependencies"
	self assert: ordered equals: orderedSuperclasses asOrderedCollection
]

{ #category : 'tests - file in/out' }
ClassTest >> testSuperclassOrderPreservingOrder [
	| noHierarchicalRelationship ordered |
	"a shuffled collection of direct subclasses of Collection"
	noHierarchicalRelationship := {CharacterSet. WideCharacterSet. OrderedDictionary. Bag. SmallDictionary. SequenceableCollection. HashedCollection. Heap}.

	ordered := Class superclassOrder: noHierarchicalRelationship.

	"should not affect the order as there is no dependencies"
	self assert: ordered equals: noHierarchicalRelationship asOrderedCollection
]

{ #category : 'tests - access' }
ClassTest >> testUsesPoolVarNamed [

	self assert: (RootClassPoolUser usesPoolVarNamed: 'AnAuthor').

	"a metaclass does not have shared pools since only classes have shared pools"
	self deny: (RootClassPoolUser class usesPoolVarNamed: 'AnAuthor').
	
	"a subclass  has  the one of its superclass"
	self assert: (SubclassPoolUser usesPoolVarNamed: 'AnAuthor')
]

{ #category : 'tests - class variables' }
ClassTest >> testclassVarNames [

	self assert: (Character classVarNames includes: #CharSet).

	"A class and it's meta-class share the class variables"
	self assert: Character classVarNames equals: Character class classVarNames
]

{ #category : 'tests - class variables' }
ClassTest >> testclassVariables [

	self assert: (Character classVariables anySatisfy: [ :cv | cv name = #CharSet ]).

	"A class and it's meta-class share the class variables"
	self assert: Character classVariables equals: Character class classVariables
]
